unit Common.Json;

interface

uses System.SysUtils, System.Classes, System.TypInfo,
    System.Generics.Collections, System.Rtti,
    Common.List, System.IniFiles, System.Json, Common.Log;

type

    TJsonOption = (useSmallCamelCase, useMini);

    TJsonOptions = set of TJsonOption;

    ISerialInterface = interface
        function CanSerialize(classType: TClass): Boolean;
        function Serialize(Obj: TObject; Ident: integer;
          Options: TJsonOptions): String;
    end;

    TJson = Class(TObject)
    protected
        class function SerializeArrayItem<T>(Obj: T;
          typeKind: TTypekind): String;
        class function Serialize<T>(arr: TArray<T>; typeKind: TTypekind)
          : String; overload;
        class function SerializeArray(arr: TValue; typeKind: TTypekind): String;
        class function Serialize(Obj: TObject; Ident: integer;
          Options: TJsonOptions): String; overload;
        class procedure loadValue(Obj: TObject; Json: TJsonObject;
          Options: TJsonOptions);
    public
        class function Serialize(Obj: TObject;
          Options: TJsonOptions = [TJsonOption.useSmallCamelCase])
          : String; overload;
        class function Deserizlize<T: class, Constructor>(JsonData: String;
          Options: TJsonOptions = [TJsonOption.useSmallCamelCase]): T;
        class procedure LoadJson(JsonData: String; Obj: TObject;
          Options: TJsonOptions = []);
        class function IsObject(JsonData: String): Boolean;
        class function IsArray(JsonData: String): Boolean;
    end;

    TCollectionInterface = class(TInterfacedObject, ISerialInterface)
    public
        function CanSerialize(classType: TClass): Boolean;
        function Serialize(Obj: TObject; Ident: integer;
          Options: TJsonOptions): String;
    end;

    TListInterface = class(TInterfacedObject, ISerialInterface)
    public
        function CanSerialize(classType: TClass): Boolean;
        function Serialize(Obj: TObject; Ident: integer;
          Options: TJsonOptions): String;
    end;

    TObjectInterface = class(TInterfacedObject, ISerialInterface)
    public
        function CanSerialize(classType: TClass): Boolean;
        function Serialize(Obj: TObject; Ident: integer;
          Options: TJsonOptions): String;
    end;

implementation

var
    interfaceList: TList<ISerialInterface>;

    { TJson }

    { TCollectionInterface }

    { TJson }

function LowerCaseFirst(orgin: String): String;
begin
    if (String.IsNullOrEmpty(orgin)) then
        exit(orgin);
    result := orgin.Substring(0, 1).ToLower() + orgin.Substring(1);
end;

function UpperCaseFirst(orgin: String): String;
begin
    if (String.IsNullOrEmpty(orgin)) then
        exit(orgin);
    result := orgin.Substring(0, 1).ToUpper() + orgin.Substring(1);
end;

function EscapeString(orgin: String): String;
begin
    result := StringReplace(orgin, '"', '&22;', [rfReplaceAll]);
end;

function UnescapeString(orgin: String): String;
begin
    result := StringReplace(orgin, '&22;', '"', [rfReplaceAll]);
end;

function Unshell(orgin: String; shellStr: string = '"'): String;
begin
    if (String.IsNullOrEmpty(orgin)) then
        exit(orgin);
    result := orgin;
    if orgin.StartsWith(shellStr) then
    begin
        result := orgin.Substring(shellStr.Length,
          orgin.Length - shellStr.Length * 2);
    end;
end;

procedure registerAllClasses();
var
    RttiContext: TRttiContext;
    types: TArray<TRttiType>;
    I: integer;
begin
    types := RttiContext.GetTypes();
    for I := Low(types) to High(types) do
    begin
        if (types[I].typeKind = tkClass) then
        begin
            if (types[I].Handle^.TypeData.classType.InheritsFrom(TPersistent))
            then
            begin
                registerClass
                  (TPersistentClass(types[I].Handle^.TypeData.classType));
            end;
        end;
    end;
end;

class function TJson.Deserizlize<T>(JsonData: String; Options: TJsonOptions): T;
var
    Rtti: TRttiContext;
    RttiType: TRttiType;
    JsonObj: TJsonObject;
    JsonValue: TJsonValue;
    cls: TClass;
    resultObj: TObject;
begin

    RttiType := Rtti.GetType(typeinfo(T));

    resultObj := nil;
    JsonObj := JsonObj.ParseJSONValue(JsonData, true, true) as TJsonObject;

    cls := FindClass(RttiType.Handle^.TypeData^.classType.ClassName);
    if assigned(cls) then
    begin
        resultObj := cls.NewInstance;
        TJson.loadValue(resultObj, JsonObj, Options);
    end;
    if assigned(resultObj) then
    begin
        result := T(resultObj);
    end;
end;

class function TJson.IsArray(JsonData: String): Boolean;
begin
    if (JsonData.IsEmpty) then
        exit(false);
    result := JsonData.Chars[0] = '[';
end;

class function TJson.IsObject(JsonData: String): Boolean;
begin
    if (JsonData.IsEmpty) then
        exit(false);
    result := JsonData.Chars[0] = '{';
end;

class procedure TJson.LoadJson(JsonData: String; Obj: TObject;
  Options: TJsonOptions);
var
    JsonObj: TJsonObject;
begin
    JsonObj := JsonObj.ParseJSONValue(JsonData, false, false) as TJsonObject;
    TJson.loadValue(Obj, JsonObj, Options);
end;

class procedure TJson.loadValue(Obj: TObject; Json: TJsonObject;
  Options: TJsonOptions);
var
    I: integer;
    Rtti: TRttiContext;
    properties: TArray<TRttiProperty>;
    prop: TRttiProperty;
    val: TJsonValue;
    objValue: TObject;
begin
    if (not assigned(Json)) then
    begin
        exit;
    end;
    properties := Rtti.GetType(Obj.classType).GetDeclaredProperties;
    for I := low(properties) to high(properties) do
    begin
        prop := properties[I];
        if (not(prop.Visibility = mvPublished)) then
            continue;
        val := Json.Values[prop.Name];
        if (not assigned(val)) and (TJsonOption.useSmallCamelCase in Options)
        then
        begin
            val := Json.Values[LowerCaseFirst(prop.Name)];
        end;
        if not assigned(val) then
            continue;
        try
            case prop.PropertyType.typeKind of
                tkChar, tkString, tkWChar, tkLString, tkWString, tkUString:
                    begin
                        prop.SetValue(Obj, UnescapeString(Unshell(val.ToString)));
                    end;
                tkClass:
                    begin
                        objValue := prop.GetValue(Obj).AsObject;
                        if not assigned(objValue) then
                        begin
                            objValue :=
                              prop.PropertyType.Handle^.TypeData.classType.
                              NewInstance;
                        end;
                        TJson.loadValue(objValue, val as TJsonObject, Options);
                    end;
                tkEnumeration:
                    begin
                        System.TypInfo.SetOrdProp(Obj, prop.Name,
                          val.GetValue<integer>);
                    end;
                tkSet:
                    begin
                        System.TypInfo.SetSetProp(Obj, prop.Name,
                          val.GetValue<String>());
                    end;
                tkInteger:
                    begin
                        prop.SetValue(Obj, val.GetValue<integer>());
                    end;
                tkInt64:
                    begin
                        prop.SetValue(Obj, val.GetValue<Int64>());
                    end;
                tkFloat:
                    begin
                        prop.SetValue(Obj, val.GetValue<Double>());
                    end;
            end;
        except
            on E: Exception do
            begin
                GLog.Error(E);
            end;
        end;
    end;
end;

class function TJson.Serialize(Obj: TObject; Options: TJsonOptions): String;
begin
    result := TJson.Serialize(Obj, 0, Options);
end;

class function TJson.Serialize(Obj: TObject; Ident: integer;
  Options: TJsonOptions): String;
var
    I: integer;
begin
    for I := interfaceList.Count - 1 downto 0 do
    begin
        if (interfaceList.Items[I].CanSerialize(Obj.classType)) then
        begin
            exit(interfaceList.Items[I].Serialize(Obj, Ident, Options));
        end;
    end;
end;

class function TJson.SerializeArray(arr: TValue; typeKind: TTypekind): String;
begin
    case typeKind of
        tkInteger:
            result := TJson.Serialize<integer>(arr.AsType < TArray < integer >>
              (), typeKind);
        tkChar:
            result := TJson.Serialize<Char>(arr.AsType < TArray < Char >> (),
              typeKind);
        tkEnumeration:
            result := TJson.Serialize<Boolean>(arr.AsType < TArray < Boolean >>
              (), typeKind);
        tkFloat:
            result := TJson.Serialize<Double>(arr.AsType < TArray < Double >>
              (), typeKind);
        tkString:
            result := TJson.Serialize<String>(arr.AsType < TArray < String >>
              (), typeKind);
        tkClass:
            result := TJson.Serialize<TObject>(arr.AsType < TArray < TObject >>
              (), typeKind);
        tkWChar:
            result := TJson.Serialize<WideChar>(arr.AsType < TArray < WideChar
              >> (), typeKind);
        tkLString:
            result := TJson.Serialize<String>(arr.AsType < TArray < String >>
              (), typeKind);
        tkWString:
            result := TJson.Serialize<String>(arr.AsType < TArray < String >>
              (), typeKind);
        tkInt64:
            result := TJson.Serialize<Int64>(arr.AsType < TArray < Int64 >> (),
              typeKind);
        tkUString:
            result := TJson.Serialize<String>(arr.AsType < TArray < String >>
              (), typeKind);
        tkClassRef:
            result := TJson.Serialize<TObject>(arr.AsType < TArray < TObject >>
              (), typeKind);
        tkPointer:
            result := TJson.Serialize<TObject>(arr.AsType < TArray < TObject >>
              (), typeKind);
    end;
end;

class function TJson.SerializeArrayItem<T>(Obj: T; typeKind: TTypekind): String;
var
    val: TValue;
begin
    val := TValue.From<T>(Obj);
    case typeKind of
        tkInteger, tkInt64, tkFloat, tkEnumeration, tkSet:
            result := val.AsString;
        tkClass:
            result := TJson.Serialize(val.AsObject);
        tkChar, tkWChar, tkLString, tkWString, tkString, tkUString:
            result := String.Format('"%s"', [val.AsString]);
    else
        begin
            GLog.Warn('Serialize arry item can not support type kind:' +
              integer(typeKind).ToString);
        end;
    end;
end;

class function TJson.Serialize<T>(arr: TArray<T>; typeKind: TTypekind): String;
var
    I: integer;
    strArr: TArray<String>;
begin
    result := '';
    setLength(strArr, Length(arr));
    for I := low(arr) to high(arr) do
    begin
        strArr[I] := TJson.SerializeArrayItem(arr[I], typeKind);
    end;
    result := Format('[%s]', [String.Join(',', strArr)]);
end;

{ TCollectionInterface }

function TCollectionInterface.CanSerialize(classType: TClass): Boolean;
begin
    result := classType.InheritsFrom(TCollection);
end;

function TCollectionInterface.Serialize(Obj: TObject; Ident: integer;
  Options: TJsonOptions): String;
var
    I: integer;
    strList: array of String;
begin
    result := '';
    setLength(strList, TCollection(Obj).Count);
    for I := 0 to TCollection(Obj).Count - 1 do
    begin
        strList[I] := TJson.Serialize(TCollection(Obj).Items[I]);
    end;
    result := string.Join(',', strList, 0, TCollection(Obj).Count);
    result := Format('[%s]', [result]);
end;

{ TListInterface }

function TListInterface.CanSerialize(classType: TClass): Boolean;
begin
    result := classType.InheritsFrom(TList);
end;

function TListInterface.Serialize(Obj: TObject; Ident: integer;
  Options: TJsonOptions): String;
var
    I: integer;
    strList: array of String;
begin
    result := '';
    setLength(strList, TList(Obj).Count);
    for I := 0 to TList(Obj).Count - 1 do
    begin
        strList[I] := TJson.Serialize(TList(Obj).Items[I]);
    end;
    result := string.Join(',', strList, 0, TList(Obj).Count);
    result := Format('[%s]', [result]);
end;

{ TObjectInterface }

function TObjectInterface.CanSerialize(classType: TClass): Boolean;
begin
    result := classType.InheritsFrom(TObject);
end;

function TObjectInterface.Serialize(Obj: TObject; Ident: integer;
  Options: TJsonOptions): String;
var
    I: integer;
    Rtti: TRttiContext;
    properties: TArray<TRttiProperty>;
    prop: TRttiProperty;
    strs: TArray<String>;
    strFields: TList<String>;
    fieldStr, PropName: String;
    val: TValue;
    identStr, closeIdentStr, breakStr: String;

begin
    properties := Rtti.GetType(Obj.classType).GetDeclaredProperties;
    strFields := TList<String>.create();
    identStr := ''.padLeft((Ident + 1) * 4);
    closeIdentStr := ''.padLeft(Ident * 4);
    breakStr := #13#10;
    if (TJsonOption.useMini in Options) then
    begin
        breakStr := '';
        identStr := '';
        closeIdentStr := '';
    end;
    for I := low(properties) to high(properties) do
    begin
        prop := properties[I];
        fieldStr := '';
        val := prop.GetValue(Obj);
        if (val.IsEmpty) then
            continue;
        if (not(prop.Visibility = mvPublished)) then
            continue;
        PropName := prop.Name;
        if (TJsonOption.useSmallCamelCase in Options) then
        begin
            PropName := LowerCaseFirst(PropName);
        end;
        try
            case prop.PropertyType.typeKind of
                tkChar, tkString, tkWChar, tkLString, tkWString, tkVariant,
                  tkUString, tkPointer:
                    begin
                        fieldStr :=
                          Format('"%s":"%s"',
                          [PropName, EscapeString(prop.GetValue(Obj)
                          .ToString)]);
                    end;
                tkClassRef:
                    begin
                        GLog > Obj.ClassName + '.record.' + prop.Name + '.' +
                          prop.PropertyType.Name
                    end;
                tkRecord, tkMRecord:
                    begin
                        GLog > Obj.ClassName + '.record.' + prop.Name + '.' +
                          prop.PropertyType.Name
                    end;
                tkClass:
                    begin
                        fieldStr :=
                          Format('"%s":%s',
                          [PropName, TJson.Serialize(val.AsObject, Ident + 1,
                          Options)]);
                    end;
                tkEnumeration:
                    begin
                        fieldStr :=
                          Format('"%s":%d',
                          [PropName,
                          System.TypInfo.GetEnumValue(prop.PropertyType.Handle,
                          val.ToString)]);
                    end;
                tkSet:
                    begin
                        fieldStr :=
                          Format('"%s":"%s"', [PropName, val.ToString]);
                    end;
                tkFloat, tkInteger, tkInt64:
                    begin
                        fieldStr :=
                          Format('"%s":%s',
                          [PropName, prop.GetValue(Obj).ToString]);
                    end;
            else
                begin
                    GLog > Obj.ClassName + '.' + prop.Name + '.' +
                      prop.PropertyType.Name
                end;
            end;
        except
            on E: Exception do
            begin
                GLog.E(PropName + ' error:' + E.Message)
            end;
        end;
        if not String.IsNullOrEmpty(fieldStr) then
        begin
            strFields.Add(identStr + fieldStr);
        end;
    end;

    if strFields.Count > 0 then
    begin
        strs := strFields.ToArray;
        result := String.Join(',' + breakStr, strs);
        setLength(strs, 0);
    end;
    result := Format('{' + breakStr + '%s' + breakStr + '%s}',
      [result, closeIdentStr]);
    strFields.Free;
end;

initialization

interfaceList := TList<ISerialInterface>.create;
interfaceList.Add(TObjectInterface.create);
interfaceList.Add(TListInterface.create);
interfaceList.Add(TCollectionInterface.create);
registerAllClasses();

finalization

interfaceList.Free;

end.
